home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpcall.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  11KB  |  269 lines
  1. ;;; CMPCALL  Function call.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'funcall 'c2funcall 'c2)
  10. (si:putprop 'call-lambda 'c2call-lambda 'c2)
  11. (si:putprop 'call-global 'c2call-global 'c2)
  12.  
  13. (defun c1funob (fun &aux fd)
  14.   ;;; NARGS is the number of arguments.  If the number is unknown, (e.g.
  15.   ;;; in case of APPLY), then NARGS should be NIL.
  16.   (or
  17.    (and
  18.     (consp fun)
  19.     (or (and (eq (car fun) 'quote)
  20.              (not (endp (cdr fun)))
  21.              (endp (cddr fun))
  22.              (or (and (consp (cadr fun))
  23.                       (not (endp (cdadr fun)))
  24.                       (eq (caadr fun) 'lambda)
  25.                       (let ((*vars* nil) (*funs* nil) (*blocks* nil)
  26.                                          (*tags* nil))
  27.                            (let ((lambda-expr (c1lambda-expr (cdadr fun))))
  28.                                 (list 'call-lambda (cadr lambda-expr)
  29.                                       lambda-expr))))
  30.                  (and (symbolp (cadr fun))
  31.                       (or (and (setq fd (c1local-fun (cadr fun)))
  32.                                (eq (car fd) 'call-local)
  33.                                fd)
  34.                           (list 'call-global
  35.                                 (make-info
  36.                                  :sp-change
  37.                                  (null (get (cadr fun) 'no-sp-change)))
  38.                                 (cadr fun)))
  39.                       )))
  40.         (and (eq (car fun) 'function)
  41.              (not (endp (cdr fun)))
  42.              (endp (cddr fun))
  43.              (or (and (consp (cadr fun))
  44.                       (eq (caadr fun) 'lambda)
  45.                       (not (endp (cdadr fun)))
  46.                       (let ((lambda-expr (c1lambda-expr (cdadr fun))))
  47.                            (list 'call-lambda (cadr lambda-expr) lambda-expr))
  48.                       )
  49.                  (and (symbolp (cadr fun))
  50.                       (or (and (setq fd (c1local-fun (cadr fun)))
  51.                                (eq (car fd) 'call-local)
  52.                                fd)
  53.                           (list 'call-global
  54.                                 (make-info
  55.                                  :sp-change
  56.                                  (null (get (cadr fun) 'no-sp-change)))
  57.                                 (cadr fun)))
  58.                       )))))
  59.    (let ((x (c1expr fun)) (info (make-info :sp-change t)))
  60.         (add-info info (cadr x))
  61.         (list 'ordinary info x))
  62.    ))
  63.  
  64. (defun c2funcall (funob args &optional (loc nil))
  65.   ;;; Usually, ARGS holds a list of forms, which are arguments to the
  66.   ;;; function.  If, however, the arguments are already pushed on the stack,
  67.   ;;; ARGS should be set to the symbol ARGS-PUSHED.
  68.   (case (car funob)
  69.     (call-global (c2call-global (caddr funob) args loc t))
  70.     (call-local (c2call-local (cddr funob) args))
  71.     (call-lambda (c2call-lambda (caddr funob) args))
  72.     (ordinary        ;;; An ordinary expression.  In this case, if
  73.                       ;;; arguments are already pushed on the stack, then
  74.                       ;;; LOC cannot be NIL.  Callers of C2FUNCALL must be
  75.                       ;;; responsible for maintaining this condition.
  76.       (let ((*vs* *vs*) (form (caddr funob)))
  77.            (declare (object form))
  78.            (unless loc
  79.              (unless (listp args) (baboon))
  80.              (cond ((eq (car form) 'LOCATION) (setq loc (caddr form)))
  81.                    ((and (eq (car form) 'VAR)
  82.                          (not (args-info-changed-vars (caaddr form) args)))
  83.                     (setq loc (cons 'VAR (caddr form))))
  84.                    (t
  85.                     (setq loc (list 'vs (vs-push)))
  86.                     (let ((*value-to-go* loc)) (c2expr* (caddr funob))))))
  87.            (push-args args)
  88.            (if *compiler-push-events*
  89.                (wt-nl "super_funcall(" loc ");")
  90.                (wt-nl "super_funcall_no_event(" loc ");"))
  91.            (unwind-exit 'fun-val)))
  92.     (otherwise (baboon))
  93.     ))
  94.  
  95. (defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr)))
  96.   (declare (object lambda-list))
  97.   (cond ((or (cadr lambda-list)        ;;; Has optional?
  98.              (caddr lambda-list)    ;;; Has rest?
  99.              (cadddr lambda-list)    ;;; Has key?
  100.              (not (listp args))        ;;; Args already pushed?
  101.              )
  102.          (when (listp args)        ;;; Args already pushed?
  103.            (let ((*vs* *vs*) (base *vs*))
  104.                 (push-args-lispcall args)
  105.                 (when (need-to-set-vs-pointers lambda-list)
  106.                   (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  107.                   (base-used)
  108.                   )))
  109.          (c2lambda-expr lambda-list (caddr (cddr lambda-expr)))
  110.          )
  111.         (t (c2let (car lambda-list) args (caddr (cddr lambda-expr)))))
  112.   )
  113.  
  114. (defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*))
  115.   (if (inline-possible fname)
  116.     (cond 
  117.      ;;; Tail-recursive case.
  118.      ((and (listp args)
  119.            *do-tail-recursion*
  120.            *tail-recursion-info*
  121.            (eq (car *tail-recursion-info*) fname)
  122.            (member *exit*
  123.                    '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT
  124.                             RETURN-LONG-FLOAT RETURN-OBJECT))
  125.            (tail-recursion-possible)
  126.            (= (length args) (length (cdr *tail-recursion-info*))))
  127.       (let* ((*value-to-go* 'trash)
  128.              (*exit* (next-label))
  129.              (*unwind-exit* (cons *exit* *unwind-exit*)))
  130.             (c2psetq (mapcar #'(lambda (v) (list v nil))
  131.                              (cdr *tail-recursion-info*))
  132.                      args)
  133.             (wt-label *exit*))
  134.       (unwind-no-exit 'tail-recursion-mark)
  135.       (wt-nl "goto TTL;")
  136.       (cmpnote "Tail-recursive call of ~s was replaced by iteration." fname))
  137.  
  138.      ;;; Open-codable function call.
  139.      ((and (listp args)
  140.            (null loc)
  141.            (setq fd (get-inline-info fname args return-type)))
  142.       (let ((*inline-blocks* 0))
  143.            (unwind-exit (get-inline-loc fd args))
  144.            (close-inline-blocks)))
  145.  
  146.      ;;; Call to a function whose C language function name is known.
  147.      ((setq fd (or (get fname 'Lfun) (get fname 'Ufun)))
  148.       (push-args args)
  149.       (wt-nl fd "();")
  150.       (unwind-exit 'fun-val)
  151.       )
  152.  
  153.      ;;; Call to a function defined in the same file.
  154.      ((setq fd (assoc fname *global-funs*))
  155.       (push-args args)
  156.       (wt-nl "L" (cdr fd) "();")
  157.       (unwind-exit 'fun-val)
  158.       )
  159.  
  160.      ;;; Otherwise.
  161.      (t (c2call-unknown-global fname args loc t)))
  162.     (c2call-unknown-global fname args loc nil))
  163.   )
  164.  
  165. (si:putprop 'simple-call 'wt-simple-call 'wt-loc)
  166.  
  167. (defun wt-simple-call (cfun base n &optional (vv-index nil))
  168.   (wt "simple_" cfun "(")
  169.   (when vv-index (wt "VV[" vv-index "],"))
  170.   (wt "base+" base "," n ")")
  171.   (base-used))
  172.  
  173. ;;; Functions that use SAVE-FUNOB should reset *vs*.
  174. (defun save-funob (funob)
  175.   (case (car funob)
  176.         ((call-lambda call-quote-lambda call-local))
  177.         (call-global
  178.          (unless (and (inline-possible (caddr funob))
  179.                       (or (get (caddr funob) 'Lfun)
  180.                           (get (caddr funob) 'Ufun)
  181.                           (assoc (caddr funob) *global-funs*)))
  182.            (let ((temp (list 'vs (vs-push))))
  183.                 (if *safe-compile*
  184.                     (wt-nl
  185.                      temp
  186.                      "=symbol_function(VV[" (add-symbol (caddr funob)) "]);")
  187.                     (wt-nl temp
  188.                            "=VV[" (add-symbol (caddr funob)) "]->s.s_gfdef;"))
  189.                 temp)))
  190.         (ordinary (let* ((temp (list 'vs (vs-push)))
  191.                          (*value-to-go* temp))
  192.                         (c2expr* (caddr funob))
  193.                         temp))
  194.         (otherwise (baboon))
  195.         ))
  196.  
  197. (defun push-args (args)
  198.   (cond ((null args) (wt-nl "vs_base=vs_top;"))
  199.         ((consp args)
  200.          (let ((*vs* *vs*) (base *vs*))
  201.            (dolist** (arg args)
  202.              (let ((*value-to-go* (list 'vs (vs-push))))
  203.                (c2expr* arg)))
  204.            (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  205.            (base-used)))))
  206.  
  207. (defun push-args-lispcall (args)
  208.   (dolist** (arg args)
  209.     (let ((*value-to-go* (list 'vs (vs-push))))
  210.       (c2expr* arg))))
  211.  
  212. (defun c2call-unknown-global (fname args loc inline-p)
  213.   (cond (*compiler-push-events*
  214.          ;;; Want to set up the return catcher.
  215.          (unless loc
  216.            (setq loc (list 'vs (vs-push)))
  217.            (wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);"))
  218.          (push-args args)
  219.          (wt-nl "funcall_with_catcher(VV[" (add-symbol fname) "]," loc  ");")
  220.          (unwind-exit 'fun-val))
  221.         (loc
  222.          ;;; The function was already pushed.
  223.          (push-args args)
  224.          (if inline-p
  225.              (if *safe-compile*
  226.                  (wt-nl "funcall_no_event(" loc ");")
  227.                  (wt-nl "CMPfuncall(" loc  ");"))
  228.              (wt-nl "funcall(" loc  ");"))
  229.          (unwind-exit 'fun-val))
  230.         ((args-cause-side-effect args)
  231.          ;;; Evaluation of the arguments may cause side-effect.
  232.          ;;; Arguments are not yet pushed.
  233.          (let ((base *vs*))
  234.               (setq loc (list 'vs (vs-push)))
  235.               (if *safe-compile*
  236.                   (wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);")
  237.                   (wt-nl loc "=(VV[" (add-symbol fname) "]->s.s_gfdef);"))
  238.               (push-args-lispcall args)
  239.               (cond ((or (eq *value-to-go* 'return)
  240.                          (eq *value-to-go* 'top))
  241.                      (wt-nl "lispcall")
  242.                      (when inline-p (wt "_no_event"))
  243.                      (wt "(base+" base "," (length args) ");")
  244.                      (base-used)
  245.                      (unwind-exit 'fun-val))
  246.                     (t (unwind-exit
  247.                         (list 'SIMPLE-CALL
  248.                               (if inline-p "lispcall_no_event" "lispcall")
  249.                               base (length args))))))
  250.          )
  251.         (t
  252.          ;;; Evaluation of the arguments causes no side-effect.
  253.          ;;; Arguments are not yet pushed.
  254.          (let ((base *vs*))
  255.               (push-args-lispcall args)
  256.               (cond ((or (eq *value-to-go* 'return)
  257.                          (eq *value-to-go* 'top))
  258.                      (wt-nl "symlispcall")
  259.                      (when inline-p (wt "_no_event"))
  260.                      (wt "(VV[" (add-symbol fname) "],base+" base ","
  261.                          (length args) ");")
  262.                      (base-used)
  263.                      (unwind-exit 'fun-val))
  264.                     (t (unwind-exit
  265.                         (list 'SIMPLE-CALL
  266.                           (if inline-p "symlispcall_no_event" "symlispcall")
  267.                           base (length args) (add-symbol fname))))))
  268.          )))
  269.